PCMania 64/PCMania CD64_1.iso/phy/phy005/3d/3dv14.pas

Pascal/Delphi Source File | 1997-09-14 | 14.9 KB | 487 lines

{$M 65520,0,655200}                                                                               {

Vulkanus demo......  "My computer, My hero, My God, My life"

PROJECTE: EUSKAL PARTY : " TUNGUSKA " By Skynet                                }

Program TUNGUSKA;

Uses Crt,Grflib,PasDVT;   {Carregue la graph i el Vangelis Tracker}

Const Tecta=0.017453292519943295769;  {Operacions predisenyades}
      COST =0.999847695156391239157;
      SINT =0.017452406437283512819;

      arxiu='data2.asc';

      MAXVERTEX=750;
      MAXFACES=1024;


Type Enter=-1000..1000;
     TresD=Record
             X,Y,Z :Real;
           End;
     Graf =Record
             A,B,C,Col:Enter;
             D:TresD;
           End;
     Cent =Record
             A:Enter;
             B:Real;
           End;
     Palette=Record
             R,G,B:Byte;
           End;

Var Cad:String;
    code,i,pol:Integer;
    VArray:Array [0..MAXVERTEX] of TresD;
    VPolig:Array [0..MAXFACES] of Graf;
    PV,p:Byte;
    Error:Boolean;
    Vorto:Array[0..MAXFACES] of Cent;
    f:file of palette;
    paleta:palette;

{ Procediments de Rotacio 3D--------------------------------------------- }
{Realitzen una variacio de tots els components en cert sentit, A mes tambe
realitzen la operacio sobre el ortocentre del poligon}


{MOMENTANI....Cal realitzar una traça precalculada.......!!!!!!!!!!!}

Procedure Rotx(var Dades:Array of TresD;var Pol:Array of Graf);
   Var i : integer;
   Begin
     for i := 0 to MAXVERTEX do
       begin
         dades[i].y := dades[i].y * COST + dades[i].z * SINT;
         dades[i].z :=-dades[i].y * SINT + dades[i].z * COST;
         If i<=MAXFACES then
           begin
             pol[i].D.y := pol[i].D.y * COST + pol[i].D.z * SINT;
             pol[i].D.z :=-pol[i].D.y * SINT + pol[i].D.z * COST;
           end;
       end;
   End;

Procedure Roty(var dades:Array of TresD;var Pol:Array of Graf);
   Var i : integer;
   Begin
     For i := 0 to MAXVERTEX do
       Begin
         dades[i].x := dades[i].x * COST - dades[i].z * SINT;
         dades[i].z := dades[i].x * SINT + dades[i].z * COST;
         if i<=MAXFACES then
            begin
              pol[i].D.x:=pol[i].D.x*COST - pol[i].D.z* SINT;
              pol[i].D.z:=pol[i].D.x*SINT + pol[i].D.z* COST;
            end;
       End;
   End;

Procedure Rotz(var dades:Array of TresD;var Pol:Array of Graf);
   Var i : integer;
   Begin
      For i := 0 to MAXVERTEX do
        Begin
           dades[i].x := dades[i].x * COST + dades[i].y * SINT;
           dades[i].y :=-dades[i].x * SINT + dades[i].y * COST;
           If i<=MAXFACES then
             begin
               pol[i].D.x:= pol[i].D.x*COST + pol[i].D.y*SINT;
               pol[i].D.y:= pol[i].D.x*SINT + pol[i].D.y*COST;
             End;
        End;
   End;

{Procediments de carrega dels poligons i dels vertex------------------------}

Function existeix(s:string):boolean;
   Var f:file;
   Begin
     {$I-}
     assign(f,s);
     reset(f);
     close(f);
     {$I+}
     existeix:=(IOResult=0) and (s <>'');
   End;

Procedure Load_Vertex(Var VArray:Array of TresD;Var Error:Boolean);
   Var I,n,j:Integer;
       data:Text;
       Cad,nombre:String;
       car:char;
    Begin
       j:=0;
       nombre:='';
       assign(data,Arxiu);
       if Not(existeix(arxiu)) then
           Error:=True  {Activara el missatge d'error}
       Else
         Begin
           Error:=False;
           reset(data);
           readln(data,cad);
           delete(cad,14,100);
           if not(cad='Ambient light') then
              Error:=True
           Else
             Begin
               While cad<>'Vertex list:' do
                 readln(data,cad);
               readln(data,cad);
               While cad<>'Face list:' do
                 begin
                   cad:=cad+'                                                                    ';
                   {El espai final parara la busqueda}
                   n:=1;
                   For I:=13 to 70 do
                     if cad[i]=':' then
                        begin
                          if n=1 then {posar en X}
                            begin
                             Inc(n,1);
                             while cad[i+2]<>' ' do
                               Begin
                                 nombre:=nombre+cad[i+2];
                                 Inc(i,1);
                               end;
                             val(nombre,Varray[j].X,code); {La j es el vertex}
                             Varray[j].X:=Varray[j].X+0.000666;
                             nombre:='';
                            end
                          else
                            if n=2 then {posar en Y}
                              begin
                                Inc(n,1);
                                while cad[i+2]<>' ' do
                                  Begin
                                    nombre:=nombre+cad[i+2];
                                    Inc(i,1);
                                  end;
                                val(nombre,Varray[j].Y,code);
                                Varray[j].Y:=Varray[j].Y+0.000666;
                                nombre:='';
                              end
                            else        {posar en Z}
                              begin
                                n:=0;
                                while cad[i+2]<>' ' do
                                  Begin
                                    nombre:=nombre+cad[i+2];
                                    Inc(i,1);
                                  end;
                                val(nombre,Varray[j].Z,code);
                                Varray[j].Z:=Varray[j].Z+0.000666;
                                nombre:='';
                                inc(j,1);
                                i:=70;
                              end;
                        end;
                     readln(data,cad);
                 end;
             End;
         End;
       close(data);
    End;

Procedure Load_Poligon(Var Vpolig:Array of Graf;var j:integer);
   Var I,n:Integer;
       Cad,comp,nombre:String;
       data:text;
    Begin
      j:=0;
      nombre:='';
      Assign(data,arxiu);
      reset(data);
      readln(data,cad);
      While cad<>'Face list:' do
        readln(data,cad);
      readln(data,cad);
      While not(eof(data)) do
        Begin
            comp:=cad;
            delete(comp,5,100);
            if not(comp='Face') then
               readln(data,cad)
            else
              begin
                cad:=cad+'                                                                    ';
                   {El espai final parara la busqueda}
                   n:=1;
                   For I:=10 to 50 do
                     if cad[i]=':' then
                        begin
                          if n=1 then {posar en X}
                            begin
                             Inc(n,1);
                             while cad[i+1]<>' ' do
                               Begin
                                 nombre:=nombre+cad[i+1];
                                 Inc(i,1);
                               end;
                             val(nombre,Vpolig[j].a,code); {La j es el vertex}
                             nombre:='';
                            end
                          else
                            if n=2 then {posar en Y}
                              begin
                                Inc(n,1);
                                while cad[i+1]<>' ' do
                                  Begin
                                    nombre:=nombre+cad[i+1];
                                    Inc(i,1);
                                  end;
                                val(nombre,Vpolig[j].b,code);
                                nombre:='';
                              end
                            else        {posar en Z}
                              begin
                                n:=0;
                                while cad[i+1]<>' ' do
                                  Begin
                                    nombre:=nombre+cad[i+1];
                                    Inc(i,1);
                                  end;
                                val(nombre,Vpolig[j].c,code);
                                nombre:='';
                                inc(j,1);
                                i:=50;
                              end;
                        end;
                     readln(data,cad);
                End;
        End;
    End;

Procedure Create_Ortocenters(Varray:Array of TresD;var Vpolig:Array of Graf;pol:integer;var Vorto:Array of cent);
  Var I:Integer;
   Begin
     For I:=0 to POL-1 do
       Begin
         Vpolig[I].D.X:=(Varray[Vpolig[I].a].x+Varray[Vpolig[I].b].x+Varray[Vpolig[I].c].x)/3;
         Vpolig[I].D.Y:=(Varray[Vpolig[I].a].y+Varray[Vpolig[I].b].y+Varray[Vpolig[I].c].y)/3;
         Vpolig[I].D.Z:=(Varray[Vpolig[I].a].z+Varray[Vpolig[I].b].z+Varray[Vpolig[I].c].z)/3;
         Vorto[I].a:=i;
         Vorto[I].b:=Vpolig[I].D.Z;
         Vpolig[I].col:=i;
       End;
   End;

Procedure Orto_Sort(Vpolig:Array of Graf;pol:integer;VAR VOrtos:Array of Cent);
  Var I,J:Integer;
     procedure quicksort(var a:Array of cent; Lo,Hi: integer);
         procedure sort(l,r: integer);
             var x,y: real;
                 i,j,temp,temp2:integer;
               begin
                 i:=l; j:=r; x:=a[(l+r) DIV 2].b;
                 repeat
                   while a[i].b<x do i:=i+1;
                     while x<a[j].b do j:=j-1;
                       if i<=j then
                         begin
                           temp:=a[i].a;a[i].a:=a[j].a;a[j].a:=temp;
                           y:=a[i].b; a[i].b:=a[j].b; a[j].b:=y;
                           i:=i+1; j:=j-1;
                         end;
                 until i>j;
                 if l<j then sort(l,j);
                 if i<r then sort(i,r);
               end;

         begin {quicksort};
           sort(Lo,Hi);
         end;
    Begin
      Quicksort(VOrtos,0,pol);
    End;


{ Dibuixa tots els poligons que conte el objecte ----------------------------}

Procedure Poligono (x1,y1,x2,y2,x3,y3,col:integer;pv:byte;origex,origey:integer);
 Var  inc_ent,inc_par,pos_ent,pos_par:longint;
      temp,cont,cont2,xmin,xmax      :integer;

Begin

 x1:=x1+origex;
 x2:=x2+origex;
 x3:=x3+origex;
 y1:=y1+origey;
 y2:=y2+origey;
 y3:=y3+origey;
     if Y1>Y3 then
        begin
             temp:=X3;
             X3:=X1;
             X1:=temp;
             temp:=Y3;
             Y3:=Y1;
             Y1:=temp;
        end;

     if Y1>Y2 then
        begin
             temp:=X2;
             X2:=X1;
             X1:=temp;
             temp:=Y2;
             Y2:=Y1;
             Y1:=temp;
        end;

     if Y2>Y3 then
        begin
             temp:=X3;
             X3:=X2;
             X2:=temp;
             temp:=Y3;
             Y3:=Y2;
             Y2:=temp;
        end;
    pos_ent:=65536*X1;
    if (Y3-Y1)>0 then inc_ent:=65536*(X3-X1) div (Y3-Y1);
    pos_par:=65536*X1;
    if (Y2-Y1)>0 then inc_par:=65536*(X2-X1) div (Y2-Y1);
    for cont:=Y1 to Y2-1 do
        begin
             xmin:=pos_ent div 65536;
             xmax:=pos_par div 65536;
             if xmax<xmin then
                begin
                     temp:=xmax;
                     xmax:=xmin;
                     xmin:=temp;
                end;
             for cont2:=xmin to xmax-1 do fponpixel(cont2,cont,col,pv);
             pos_ent:=pos_ent+inc_ent;
             pos_par:=pos_par+inc_par;
        end;
    pos_par:=65536*X2;
    if (Y3-Y2)>0 then inc_par:=65536*(X3-X2) div (Y3-Y2);
    for cont:=Y2 to Y3-1 do
        begin
             xmin:=pos_ent div 65536;
             xmax:=pos_par div 65536;
             if xmax<xmin then
                begin
                     temp:=xmax;
                     xmax:=xmin;
                     xmin:=temp;
                end;
             for cont2:=xmin to xmax-1 do ponpixel(cont2,cont,col,pv);
             pos_ent:=pos_ent+inc_ent;
             pos_par:=pos_par+inc_par;
        end;
end;

Procedure Draw_3d(Varray:Array of TresD;Vpolig:Array of graf;
                        c,pv:byte;origeX,origeY,pol:Integer;vorto:array of cent);


   Procedure lines(x1, y1, x2, y2: real;c,pv:byte;origeX,OrigeY:integer);
   Begin
    fLinea(round(x1) + origeX,round(y1) + origeY,round(x2) + origeX,round(y2) + origeY,c,PV);
   End;

   Var I:integer;

      Begin
        For I:=0 to (pol-1) do
          Begin
           poligono(round(Varray[Vpolig[Vorto[I].a].a].X),round(Varray[Vpolig[vorto[I].a].a].y),
           round(Varray[Vpolig[vorto[i].a].b].X),round(Varray[Vpolig[vorto[i].a].b].y),
           round(Varray[Vpolig[vorto[i].a].c].X),round(Varray[Vpolig[vorto[i].a].c].y),Vpolig[i].col,pv,origex,origey);

          End
      End;

Procedure Increment(Var Varray:Array of TresD;n:real);
   Var I:integer;
   Begin
     For I:=0 to 660 do
       Begin
        Varray[i].x:=(Varray[i].x/100)*n;
        Varray[i].y:=(Varray[i].y/100)*n;
        Varray[i].z:=(Varray[i].z/100)*n;
       End;
   End;

{-------------------------------Programa Principal---------------------------}


BEGIN
 {OUTPUT-----------------------------------}

  ClrScr;
  TextBackground(Blue);
  Writeln('3D Vulkanus.                    PROJECTE TUNGUSKA.                  By Skynet');
  TextBackground(Black);
  Writeln;
  Writeln;

 {-----------------Programa----------------}

{  IF NOT VT_Init THEN
    BEGIN
     WriteLn('Driver no detectat! Si continues, no obtindras musica...');
     readln;
    END;

  {ENTORN DEL VANGELIS TRACKER-------Llegir intruccions}

{  VT_GoTo(1, 1);
  VT_Autoon;
  VT_SetVolume(255);
  VT_Start;
  VT_SyncStart;

  {ALGORITMES ARXIUS------------------------------------}

  Load_Vertex (VArray,Error);
  If Error then
     Begin
       Writeln('Arxiu no trobat o aquest no correspon al format del 3D Studio');
       readln;
       halt(27);
     End;
  Load_Poligon(VPolig,pol);
  Create_Ortocenters(Varray,Vpolig,pol,Vorto);
  {ALGORITMES GRAFICS-----------------------------------}

  ModoGrafico;
  PV:=CreaVirtual;
  fBorraPantalla(0,0);
  fBorraPantalla(0,PV);
  increment(varray,70);
   for i:=0 to 255 do
     poncolor(i,0,0,i);
  repeat
    draw_3d(VArray,Vpolig,0,pv,160,100,pol,vorto);
    CopiaPantalla(PV,0);
    rotx(Varray,Vpolig);
    roty(Varray,Vpolig);
    rotz(Varray,Vpolig);
    fborrapantalla(0,pv);
    Orto_Sort(Vpolig,pol,VOrto);
  until keypressed;

  Fadedown(2000,1,0);

 { For p:=VT_GetVolume downto 0 do
    Begin
     VT_Setvolume(p);
     delay(3);
    End;}

  ModoTexto;
 { VT_AutoOff;
  VT_Abort;}

END.